home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / nt / jx4nt125.zip / JX4FILES.A < prev    next >
Text File  |  1994-10-10  |  30KB  |  967 lines
  1. ; jx4files.a ... File-Access wordset words for Jax4th 32-bit ANS Forth for Windows NT
  2. ; copyright (c) 1993, 1994 by jack j. woehr
  3. ; p.o. box 51, golden, co 80402-0051
  4. ; jax@well.sf.ca.us | JAX on GEnie | 72203.1320@compuserve.com
  5. ; sysop, rcfb (303) 278-0364
  6.  
  7.     COMMENT    !
  8. This program is free software; you can redistribute it and/or modify
  9. it under the terms of the GNU General Public License as published by
  10. the Free Software Foundation; either version 2 of the License, or
  11. (at your option) any later version.
  12.  
  13. This program is distributed in the hope that it will be useful,
  14. but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. GNU General Public License for more details. (doc\license.txt)
  17.  
  18. You should have received a copy of the GNU General Public License
  19. along with this program; if not, write to the Free Software
  20. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  21. !
  22.  
  23. ;
  24. ; $Log: jx4files.a,v $
  25. ; Revision 1.9  1994/08/21  07:35:12  jax
  26. ; Fixed OPEN-FILE to do its own null padding.
  27. ;
  28. ; Revision 1.9  1994/08/21  07:35:12  jax
  29. ; Fixed OPEN-FILE to do its own null padding.
  30. ;
  31. ; Revision 1.8  1994/08/20  09:27:14  jax
  32. ; Added INCLUDED.
  33. ; Fixed CREATE-FILE to do its own null appending.
  34. ;
  35. ; Revision 1.7  1994/08/20  05:51:03  jax
  36. ; added INCLUDE-FILE
  37. ;
  38. ; Revision 1.6  1994/08/04  02:02:24  jax
  39. ; Added READ-LINE. Moved the A and W words to NONSTANDARD-WORDLIST.
  40. ;
  41. ; Revision 1.5  1994/07/28  18:26:23  jax
  42. ; Changed all the file words so that they have both ascii and
  43. ; unicode versions, with a deferred top-level word init'ed
  44. ; by COLD at powerup.
  45. ;
  46. ; Revision 1.4  1994/07/18  07:05:57  jax
  47. ; Worked on READ-LINE, didn't finish.
  48. ;
  49. ; Revision 1.3  1994/06/13  22:40:54  jax
  50. ; masm 6.11 protos
  51. ;
  52. ; Revision 1.2  1994/05/21  06:25:03  jax
  53. ; Changed copyright dates.
  54. ;
  55. ; Revision 1.1  1993/12/29  21:06:34  jax
  56. ; Initial revision
  57. ;
  58.  
  59.     fnamemanque    <CLOSE-FILE>    ; fileid -- ior ( == system error if failure, == 0 if success)
  60. fw_CLOSEFILE:                ; FILE
  61.     docode
  62.     call    CloseHandle
  63.     and    eax,eax            ; indicates success, but we reverse the code
  64.     jne    closefile1
  65.     INVOKE    GetLastError        ; get error
  66.     push    eax            ; push error ior
  67.     store    lastError,eax        ; to be consistent with rest of system
  68.     next
  69. closefile1:
  70.     xor    eax,eax
  71.     push    eax            ; success
  72.     next
  73.  
  74.  
  75.     fnamemanque    <CREATE-FILE>    ; c-addr u x1 -- x2 ior (== 0 | system err)
  76. fw_CREATEFILE:                ; FILE
  77.     ctok    NEST
  78.     ctok    TO_R        ; -- c-addr u            R: -- x1
  79.     ctok    CHARS
  80.     ctok    TUCK        ; -- u' c-addr u'        R: -- x1
  81.     literal zeroBuffer    ; -- u' c-addr1 u' c-addr2    R: -- x1
  82.     ctok    SWAP        ; -- u' c-addr1 c-addr2 u'    R: -- x1
  83.     ctok    MOVE        ; -- u'             R: -- x1
  84.     literal    zeroBuffer    ; -- u' c-addr            R: -- x1
  85.     ctok    OVER        ; -- u' c-addr u'        R: -- x1
  86.     ctok    PLUS        ; -- u' c-addr'            R: -- x1
  87.     literal    0        ; -- u' c-addr' 0        R: -- x1
  88.     ctok    SWAP        ; -- u' 0 c-addr'        R: -- x1
  89.     ctok    C_STORE        ; -- u'                R: --
  90.     literal    zeroBuffer    ; -- u' c-addr            R: -- x1
  91.     ctok    SWAP        ; -- c-addr u'            R: -- x1
  92.     ctok    R_FROM        ; -- c-addr u' x1        R: --
  93.     ctok    CREATFILE    ; -- x2 ior
  94.     ctok    UNNEST
  95.     
  96.  
  97.     zname    <CREATFILE>        ; c-addr u x1 -- x2 ior (== 0 | system err)
  98.     docode
  99.     pop    eax            ; x1
  100.     pop    ecx            ; u
  101.     pop    edx            ; c-addr
  102.     add    edx,dp            ; abs-addr
  103.     INVOKE    CreateFileW, edx, eax, 0, OFFSET FLAT:secAttrib, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0
  104.     push    eax            ; push resultant handle
  105.     cmp    eax,INVALID_HANDLE_VALUE
  106.     jne    createfile1        ; if handle is invalid, we don't branch
  107.     INVOKE    GetLastError        ; get error
  108.     push    eax            ; push error ior
  109.     store    lastError,eax        ; to be consistent with rest of system
  110.     next
  111. createfile1:
  112.     xor    eax,eax
  113.     push    eax            ; success, ior is zero
  114.     next
  115.  
  116.     fnamemanque    <DELETE-FILE>    ; c-addr u -- ior (== 0 | system err)
  117. fw_DELETEFILE:                ; FILE
  118.     docode
  119.     pop    edx            ; u
  120.     pop    eax            ; c-addr
  121.     add    eax,dp            ; abs-addr
  122.     INVOKE    DeleteFileW, eax
  123.     and    eax,eax
  124.     je    deletefile1        ; if zero, we failed
  125.     xor    eax,eax            ; but our Forth result for success is zero (0)
  126.     push    eax            ; success
  127.     next
  128. deletefile1:
  129.     INVOKE    GetLastError        ; failure, get system error code
  130.     push    eax            ; push error ior
  131.     store    lastError,eax        ; to be consistent with rest of system
  132.     next
  133.     
  134.     nname    <FERROR>        ; -- a-addr
  135.     ctok    DOCONST            ; CORE
  136.     dd    var_ferror
  137.  
  138.     fnamemanque    <FILE-POSITION>
  139.                     ; fileid -- ud ior (0= success , nz== last error
  140. fw_FILEPOSITION:            ; FILE
  141.     defers
  142.  
  143.     nnamemanque    <FILE-POSITIONW>
  144.                     ; fileid -- ud-chars ior (0= success , nz== last error
  145. fw_FILEPOSITIONW:            ; FILE
  146.     ctok    NEST
  147.     ctok    FILEPOSITIONA        ; -- ud-bytes ior
  148.     ctok    TO_R            ; -- ud-bytes            R: -- ior
  149.     literal    tchar
  150.     ctok    DUMSLMOD        ; -- modulus ud-chars        R: -- ior
  151.     ctok    ROT            ; -- ud-chars modulus        R: -- ior
  152.     ctok    DROP            ; -- ud-chars            R: -- ior
  153.     ctok    R_FROM            ; -- ud-chars ior        R: --
  154.     ctok    UNNEST
  155.  
  156.     nnamemanque    <FILE-POSITIONA>
  157.                     ; fileid -- ud=-bytes ior (0= success , nz== last error
  158. fw_FILEPOSITIONA:            ; FILE
  159.     docode
  160.     pop    edx            ; fileid
  161.     mov    DWORD PTR distMoveHigh,0    ; hi word of dist to move
  162.     INVOKE    SetFilePointer, edx, 0, OFFSET FLAT:distMoveHigh, FILE_CURRENT
  163.     cmp    eax,-1            ; if -1, must check distMoveHigh
  164.     jne    filepos1
  165.     cmp    DWORD PTR distMoveHigh,0    ; if zero, we have an err
  166.     jne    filepos1        ; not zero is success
  167.     INVOKE    GetLastError        ; get error
  168.     push    0
  169.     push    0            ; ud
  170.     push    eax            ; push error ior
  171.     store    lastError,eax        ; to be consistent with rest of system
  172.     next
  173. filepos1:
  174.     push    eax
  175.     push    DWORD PTR distMoveHigh
  176.     push    0            ; success, ior is zero
  177.     next
  178.  
  179.     fnamemanque    <FILE-SIZE>    ; fileid -- ud ior
  180. fw_FILESIZE:                ; FILE
  181.     defers
  182.  
  183.     nnamemanque    <FILE-SIZEW>    ; fileid -- ud-chars ior
  184. fw_FILESIZEW:                ; FILE
  185.     ctok    NEST
  186.     ctok    FILESIZEA        ; -- ud-bytes ior
  187.     ctok    TO_R            ; -- ud-bytes        R: -- ior
  188.     literal    tchar            ; -- ud-bytes u        R: -- ior
  189.     ctok    DUMSLMOD        ; -- mod ud-chars    R: -- ior
  190.     ctok    ROT            ; -- ud-chars mod    R: -- ior
  191.     ctok    DROP            ; -- ud-chars        R: -- ior
  192.     ctok    R_FROM            ; -- ud-chars ior    R: --
  193.     ctok    UNNEST
  194.  
  195.     nnamemanque    <FILE-SIZEA>    ; fileid -- ud-bytes ior
  196. fw_FILESIZEA:                ; FILE
  197.     docode
  198.     pop    eax
  199.     INVOKE    GetFileInformationByHandle, eax, OFFSET FLAT:fileInfo
  200.     cmp    eax,0
  201.     jne    filesize1        ; if handle is invalid, we don't branch
  202.     INVOKE    GetLastError        ; get error
  203.     push    0
  204.     push    0            ; ud
  205.     push    eax            ; push error ior
  206.     store    lastError,eax        ; to be consistent with rest of system
  207.     next
  208. filesize1:
  209.     push    DWORD PTR fileInfo.nFileSizeLow
  210.     push    DWORD PTR fileInfo.nFileSizeHigh
  211.     xor    eax,eax
  212.     push    eax            ; success, ior is zero
  213.     next
  214.  
  215.     fnamemanque    <INCLUDE-FILE>    ; i*x fileid -- j*x
  216. fw_INCLUDEFILE:                ; FILE
  217.     ctok    NEST
  218.     ctok    TIB
  219.     ctok    TO_R        ; -- i*x fileid        R: -- 'TIB
  220.     ctok    NUMTIB
  221.     ctok    FETCH
  222.     ctok    TO_R        ; -- i*x fileid        R: -- 'TIB #TIB
  223.     ctok    TO_IN
  224.     ctok    FETCH
  225.     ctok    TO_R        ; -- i*x fileid        R: -- 'TIB #TIB >IN
  226.     ctok    SOURCE_ID
  227.     ctok    FETCH
  228.     ctok    TO_R        ; -- i*x fileid        R: -- 'TIB #TIB >IN SOURCE-ID
  229.     ctok    BLK
  230.     ctok    FETCH
  231.     ctok    TO_R        ; -- i*x fileid        R: -- 'TIB #TIB >IN SOURCE-ID BLK
  232.     literal    endq
  233.     ctok    FETCH
  234.     ctok    TO_R        ; -- i*x fileid        R: -- 'TIB #TIB >IN SOURCE-ID BLK endq
  235.     ctok    SOURCE_ID    ; -- i*x fileid a-addr    R: -- 'TIB #TIB >IN SOURCE-ID BLK endq    
  236.     ctok    STORE        ; -- i*x        R: -- x x x x x x
  237. incfileloop:            ; -- i*x        R: -- x x x x x x
  238.     literal    tickftib
  239.     literal    tibsize
  240.     ctok    SOURCE_ID
  241.     ctok    FETCH
  242.     ctok    READLINE    ; -- i*x u flag ior            R: -- x x x x x x
  243.     ctok    QDUP        ; -- i*x u flag ior ior|--        R: -- x x x x x x
  244.     compif    incfile1    ; -- i*x u flag ior, there was an error    R: -- x x x x x x
  245.     ctok    FERROR        ; -- i*x u flag ior a-addr        R: -- x x x x x x
  246.     ctok    STORE        ; -- i*x u flag, save file error    R: -- x x x x x x
  247.     literal    -37        ; File I/O Error
  248.     ctok    THROW        ; -- j*x n                R: -- (to be cleared)
  249. incfile1:            ; -- i*x u flag, no error, flag false or true?    R: -- x x x x x x
  250.     compif    incfile3    ; -- i*x u, true, there were some chars        R: -- x x x x x x
  251.     ctok    FALSE
  252.     literal    endq
  253.     ctok    STORE        ; -- i*x        R: -- x x x x x x
  254.     ctok    NUMTIB
  255.     ctok    STORE        ; -- i*x                    R: -- x x x x x x
  256.     literal    tickftib
  257.     ctok    TICK_TIB
  258.     ctok    STORE        ; -- i*x                    R: -- x x x x x x
  259.     ctok    FALSE
  260.     ctok    TO_IN
  261.     ctok    STORE        ; -- i*x                    R: -- x x x x x x
  262.     literal    tickftib    ; see if first char is the Unicode byte-order marker
  263.     ctok    C_FETCH        ; -- i*x char                    R: -- x x x x x x
  264.     literal    0FEFFH
  265.     ctok    EQUAL        ; -- i*x flag                    R: -- x x x x x x
  266.     compif    incfile2    ; -- i*x                    R: -- x x x x x x
  267.     ctok    BL
  268.     literal    tickftib    ; -- i*x char c-addr                R: -- x x x x x x
  269.     ctok    C_STORE        ; -- i*x                    R: -- x x x x x x
  270. incfile2:
  271.     ctok    INTERPRET    ; -- j*x
  272.     compelse    incfileloop
  273. incfile3:            ; -- j*x u, chars read (0)        R: -- x x x x x x
  274.                 ; Start restoring the input stream
  275.     ctok    DROP        ; -- j*x                R: -- x x x x x x
  276.     ctok    R_FROM
  277.     literal    endq
  278.     ctok    STORE        ; -- j*x                R: -- x x x x x 
  279.     ctok    R_FROM
  280.     ctok    BLK
  281.     ctok    STORE        ; -- j*x                R: -- x x x x
  282.     ctok    R_FROM
  283.     ctok    SOURCE_ID
  284.     ctok    STORE        ; -- j*x                R: -- x x x
  285.     ctok    R_FROM
  286.     ctok    TO_IN
  287.     ctok    STORE        ; -- j*x                R: -- x x
  288.     ctok    R_FROM
  289.     ctok    NUMTIB
  290.     ctok    STORE        ; -- j*x                R: -- x
  291.     ctok    R_FROM
  292.     ctok    TICK_TIB
  293.     ctok    STORE        ; -- j*x                R: --
  294.     ctok    UNNEST
  295.  
  296.     fname    <INCLUDED>        ; i*x c-addr u -- j*x
  297.     ctok    NEST            ; FILE
  298.     ctok    RO            ; -- x1
  299.     ctok    OPENFILE        ; -- x2 ior
  300.     ctok    QDUP
  301.     compif    included1        ; file error
  302.     ctok    FERROR
  303.     ctok    STORE            ; save error for analysis
  304.     literal    -37
  305.     ctok    THROW            ; throw exception
  306. included1:
  307.     ctok    DUP            ; -- fid fid
  308.     ctok    TO_R            ; -- fid        R: -- fid
  309.     ctok    DOLIT
  310.     ctok    INCLUDEFILE        ; -- fid xt        R: -- fid
  311.     ctok    CATCH            ; -- 0|n        R: -- fid
  312.     ctok    R_FROM            ; -- 0|n fid        R: --
  313.     ctok    CLOSEFILE        ; -- 0|n ior
  314.     ctok    DROP            ; -- 0|n
  315.     ctok    THROW            ; if an error occured, THROW it!
  316.     ctok    UNNEST
  317.  
  318.     fnamemanque    <OPEN-FILE>    ; c-addr u x1 -- x2 ior (== 0 | system err)
  319. fw_OPENFILE:                ; FILE
  320.     ctok    NEST
  321.     ctok    TO_R        ; -- c-addr u            R: -- x1
  322.     ctok    CHARS
  323.     ctok    TUCK        ; -- u' c-addr u'        R: -- x1
  324.     literal zeroBuffer    ; -- u' c-addr1 u' c-addr2    R: -- x1
  325.     ctok    SWAP        ; -- u' c-addr1 c-addr2 u'    R: -- x1
  326.     ctok    MOVE        ; -- u'             R: -- x1
  327.     literal    zeroBuffer    ; -- u' c-addr            R: -- x1
  328.     ctok    OVER        ; -- u' c-addr u'        R: -- x1
  329.     ctok    PLUS        ; -- u' c-addr'            R: -- x1
  330.     literal    0        ; -- u' c-addr' 0        R: -- x1
  331.     ctok    SWAP        ; -- u' 0 c-addr'        R: -- x1
  332.     ctok    C_STORE        ; -- u'                R: --
  333.     literal    zeroBuffer    ; -- u' c-addr            R: -- x1
  334.     ctok    SWAP        ; -- c-addr u'            R: -- x1
  335.     ctok    R_FROM        ; -- c-addr u' x1        R: --
  336.     ctok    OPEFILE        ; -- x2 ior
  337.     ctok    UNNEST
  338.     
  339.  
  340.     zname    <OPEFILE>    ; c-addr u x1 -- x2 ior (== 0 | system err)
  341.     docode
  342.     pop    eax            ; x1
  343.     pop    ecx            ; u
  344.     pop    edx            ; c-addr
  345.     add    edx,dp            ; abs-addr
  346.     INVOKE    CreateFileW, edx, eax, 0, OFFSET FLAT:secAttrib, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0
  347.     push    eax            ; push resultant handle
  348.     cmp    eax,INVALID_HANDLE_VALUE
  349.     jne    openfile1        ; if handle is invalid, we don't branch
  350.     INVOKE    GetLastError        ; get error
  351.     push    eax            ; push error ior
  352.     store    lastError,eax        ; to be consistent with rest of system
  353.     next
  354. openfile1:
  355.     xor    eax,eax
  356.     push    eax            ; success, ior is zero
  357.     next
  358.  
  359.     fnamemanque    <READ-FILE>    ; c|b-addr u1 fileid -- u2 ior
  360. fw_READFILE:
  361.     defers
  362.  
  363.     nnamemanque    <READ-FILEW>    ; c-addr u1 fileid -- u2 ior (== 0 | system err)
  364. fw_READFILEW:                ; FILE
  365.     ctok    NEST
  366.     ctok    SWAP            ; -- c-addr fileid u-chars
  367.     ctok    TWO_STAR        ; -- c-addr fileid u-bytes
  368.     ctok    SWAP            ; -- c-addr u-bytes fileid
  369.     ctok    READFILEA        ; -- u2 ior
  370.     ctok    SWAP            ; -- ior u2
  371.     ctok    TWO_SLASH        ; -- ior u2'
  372.     ctok    SWAP            ; -- u2' ior
  373.     ctok    UNNEST
  374.  
  375.     nnamemanque    <READ-FILEA>    ; b-addr u1 fileid -- u2 ior (== 0 | system err)
  376. fw_READFILEA:                ; FILE
  377.     docode
  378.     pop    edx            ; fileid
  379.     pop    ecx            ; u1
  380.     pop    eax            ; c-addr
  381.     add    eax,dp            ; abs-addr
  382.     INVOKE    ReadFile, edx, eax, ecx, OFFSET FLAT:numRead, 0
  383.     push    DWORD PTR numRead    ; u2
  384.     and    eax,eax
  385.     jne    readfile1        ; result was bool true, so we branch on success
  386.     INVOKE    GetLastError        ; get error
  387.     push    eax            ; push error ior
  388.     store    lastError,eax        ; to be consistent with rest of system
  389.     next
  390. readfile1:
  391.     xor    eax,eax
  392.     push    eax            ; success, ior is zero
  393.     next
  394.  
  395.     fnamemanque    <READ-LINE>    ; c-addr u1 fileid -- u2 flag ior (== 0 | system err)
  396. fw_READLINE:                ; FILE
  397.     ctok    NEST
  398.     ctok    SWAP        ; -- c-addr fileid u1
  399.     literal    rlbuffsize    ; -- c-addr fileid u1 n, let's only allow this many max
  400.     ctok    MIN        ; -- c-addr fileid u1'
  401.     literal    0        ; -- c-addr fileid u1' 0
  402.     ctok    MAX        ; -- c-addr fileid u1''
  403.     ctok    SWAP        ; -- c-addr u1 fileid, 0 - rlbuffsize is acceptable
  404.     ctok    DUP        ; -- c-addr u1 fileid fileid
  405.     ctok    FILESIZEW    ; -- c-addr u1 fileid ud2 ior
  406.     ctok    QDUP        ; -- c-addr u1 fileid ud2 ior ior|--
  407.     compif    rline1        ; -- c-addr u1 fileid ud2 ior, FILE-SIZE failed
  408.     ctok    TO_R        ; -- c-addr u1 fileid ud2                R: -- ior
  409.     ctok    ROT
  410.     ctok    DROP        ; -- c-addr u1 ud2                    R: -- ior    
  411.     ctok    ROT
  412.     ctok    DROP        ; -- c-addr ud2                        R: -- ior
  413.     ctok    ROT
  414.     ctok    DROP        ; -- ud2                        R: -- ior
  415.     ctok    R_FROM        ; -- x x  ior                        R: --
  416.     ctok    EXIT        ; -- u2 flag ior, failure indicated by ior, ud2 subs for u2 flag
  417. rline1:                ; we have a FILE-SIZE
  418.     literal    2
  419.     ctok    PICK        ; -- c-addr u1 fileid ud2 fileid
  420.     ctok    FILEPOSITIONW    ; -- c-addr u1 fileid ud2 ud3 ior
  421.     ctok    QDUP        ; -- c-addr u1 fileid ud2 ud3 ior ior|--
  422.     compif    rline2        ; -- c-addr u1 fileid ud2 ud3 ior, FILE-POSITION failed
  423.     ctok    TO_R        ; -- c-addr u1 fileid ud2 ud3                R: -- ior
  424.     ctok    TWO_TO_R    ; -- c-addr u1 fileid ud2                R: -- ior ud3
  425.     ctok    TWO_DROP    ; -- c-addr u1 fileid                    R: -- ior ud3
  426.     ctok    TWO_DROP    ; -- c-addr                        R: -- ior ud3
  427.     ctok    DROP        ; --                            R: -- ior ud3
  428.     ctok    TWO_R_FROM    ; -- ud2                        R: -- ior
  429.     ctok    R_FROM        ; -- x x ior                        R: --
  430.     ctok    EXIT        ; -- ud2 ior, failure indicated by ior, ud2 subs for u2 flag
  431. rline2:                ; -- c-addr u1 fileid ud2 ud3, we have file position and size
  432.     ctok    TWO_DUP        ; -- c-addr u1 fileid ud2 ud3 ud3
  433.     ctok    TWO_TO_R    ; -- c-addr u1 fileid ud2 ud3                R: -- ud3
  434.     ctok    D_EQUAL        ; -- c-addr u1 fileid flag, is the file at the end?    R: -- ud3
  435.     compif    rline3        ; -- c-addr u1 fileid, yes                R: -- ud3
  436.     ctok    TWO_R_FROM    ; -- c-addr u1 fileid ud3                R: --
  437.     ctok    TWO_DROP    ; -- c-addr u1 fileid
  438.     ctok    TWO_DROP    ; -- c-addr
  439.     ctok    DROP        ; --
  440.     ctok    FALSE
  441.     ctok    FALSE
  442.     ctok    FALSE
  443.     ctok    EXIT        ; -- 0 0 0, proper return if file was exhausted when we started
  444. rline3:                ; -- c-addr u1 fileid flag, file not at end yet        R: -- ud3
  445.     literal    rlBuffer    ; -- c-addr u1 fileid a-addr                R: -- ud3
  446.     literal    rlbuffsize    ; -- c-addr u1 fileid a-addr u2                R: -- ud3
  447.     literal    2
  448.     ctok    PICK        ; -- c-addr u1 fileid a-addr u2 fileid            R: -- ud3
  449.     ctok    READFILEW    ; -- c-addr u1 fileid u2 ior                R: -- ud3
  450.     ctok    QDUP        ; -- c-addr u1 fileid u2 ior ior|--                R: -- ud3
  451.     compif    rline4        ; -- c-addr u1 fileid u2 ior, error on read        R: -- ud3
  452.     ctok    TO_R        ; -- c-addr u1 fileid u2                R: -- ud3 ior    
  453.     ctok    TWO_DROP
  454.     ctok    TWO_DROP    ; --                            R: -- ud3 ior
  455.     ctok    FALSE
  456.     ctok    FALSE
  457.     ctok    R_FROM        ; -- 0 0 ior                        R: -- ud3
  458.     ctok    TWO_R_FROM    ; -- 0 0 ior ud3                    R: --
  459.     ctok    TWO_DROP    ; -- 0 0 ior
  460.     ctok    EXIT        ; -- 0 0 ior, this looks good on a read error
  461. rline4:                ; -- c-addr u1 fileid u2                R: -- ud3
  462.     ctok    SWAP        ; -- c-addr u1 u2 fileid            R: -- ud3
  463.     ctok    TO_R        ; -- c-addr u1 u2                R: -- ud3 fileid
  464.     literal    rlBuffer    ; -- c-addr1 u1 u2 c-addr2            R: -- ud3 fileid
  465.     ctok    SWAP        ; -- c-addr1 u1 c-addr2 u2            R: -- ud3 fileid
  466.     literal    lFeed        ; -- c-addr1 u1 c-addr2 u2 char            R: -- ud3 fileid
  467.     ctok    SCAN        ; -- c-addr1 u1 c-addr2' u2'             R: -- ud3 fileid
  468.     ctok    DROP        ; -- c-addr1 u1 c-addr2'            R: -- ud3 fileid
  469.     literal    rlBuffer    ; -- c-addr1 u1 c-addr2' c-a-buff        R: -- ud3 fileid
  470.     ctok    TUCK        ; -- c-addr1 u1 c-a-buff c-addr2' c-a-buff    R: -- ud3 fileid
  471.     ctok    MINUS        ; -- c-addr1 u1 c-a-buff ubytes            R: -- ud3 fileid
  472.     ctok    S_TO_D
  473.     literal    1
  474.     ctok    CHARS        ; dividing since  address arithmentic resulted in bytes, not chars
  475.     ctok    UMSLMOD        ; -- c-addr1 u1 c-a-buff umod uchars        R: -- ud3 fileid
  476.     ctok    NIP        ; -- c-addr1 u1 c-a-buff uchars            R: -- ud3 fileid
  477.     ctok    ONE_PLUS    ; Since SCAN returned the address of the LF,
  478.                 ; our subtraction is one char short of the total read.
  479.     ctok    TWO_DUP        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars    R: -- ud3 fileid
  480.     ctok    DUP        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars uchars        R: -- ud3 fileid
  481.     ctok    R_FROM        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars uchars fileid    R: -- ud3
  482.     ctok    SWAP        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fileid uchars    R: -- ud3
  483.     ctok    S_TO_D        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fileid ud4        R: -- ud3
  484.     ctok    TWO_R_FROM    ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud4 ud3    R: -- 
  485.     ctok    D_PLUS        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5
  486.     literal    2
  487.     ctok    PICK        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 fid
  488.     ctok    FILESIZEW    ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 ud6 ior
  489.     ctok    QDUP        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 ud6 ior ior|--
  490.     compif    rlineZZ        ; FILE-SIZE failed
  491.     ctok    TO_R        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 ud6    R: -- ior
  492.     ctok    TWO_DROP    ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5    R: -- ior
  493.     ctok    TWO_DROP    ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid    R: -- ior
  494.     ctok    TWO_DROP    ; -- c-a1 u1 c-a-buff uchars c-a-buff            R: -- ior
  495.     ctok    TWO_DROP    ; -- c-a1 u1 c-a-buff                    R: -- ior
  496.     ctok    DROP        ; -- x x                        R: -- ior
  497.     ctok    R_FROM        ; -- x x  ior                        R: --
  498.     ctok    EXIT        ; -- u2 flag ior, failure indicated by ior, ud2 subs for u2 flag
  499. rlineZZ:
  500.     ctok    UDMIN        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud'
  501.     ctok    ROT        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ud' fid
  502.     ctok    REPOFILEW    ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ior
  503.     ctok    QDUP        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ior|-
  504.     compif    rline5        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ior, we had a reposition err
  505.     ctok    NIP        ; Only the IOR matters here, so we toss three stack items
  506.     ctok    NIP        ; and, leave whatever was below to fill out stack return.
  507.     ctok    NIP        ; -- x x ior, we had a reposition error
  508.     ctok    EXIT
  509. rline5:                ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars    R: --
  510.     ctok    DUP        ; we start off assuming all chars will count in the count
  511.     ctok    TO_R        ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars    R: -- uchars
  512.     ctok    ONE_MINUS    ; -- c-a1 u1 c-a-buff uchars c-a-buff u4    R: -- uchars
  513.                 ; we want to point *to* the last char, the LF, not *past* it
  514.     ctok    CHARS        ; -- c-a1 u1 c-a-buff uchars c-a-buff u4'    R: -- uchars
  515.     ctok    PLUS        ; -- c-a1 u1 c-a-buff uchars c-addr2        R: -- uchars
  516.     ctok    DUP        ; -- v-a1 u1 c-a-buff uchars c-addr2 c-addr2    R: -- uchars
  517.     ctok    C_FETCH        ; -- c-a1 u1 c-a-buff uchars c-addr2 char    R: -- uchars
  518.     literal    lFeed
  519.     ctok    EQUAL        ; -- c-addr1 u1 c-a-buff uchars c-addr2 flag    R: -- uchars
  520.     compif    rline6        ; Last char we read into buffer turns out to be LF
  521.     ctok    R_FROM        ; -- c-addr1 u1 c-a-buff uchars c-addr2 uchars    R: --
  522.     ctok    ONE_MINUS    ; -- c-addr1 u1 c-a-buff uchars c-addr2 uchars'    R: --
  523.     ctok    TO_R        ; -- c-addr1 u1 c-a-buff uchars c-addr2        R: -- uchars'
  524.     literal    1
  525.     ctok    CHARS        ; subtract a char from the returned count
  526.     ctok    MINUS        ; -- c-addr1 u1 c-a-buff uchars c-addr2'    R: -- uchars'
  527.     ctok    C_FETCH        ; -- c-addr1 u1 c-a-buff uchars char        R: -- uchars'
  528.     literal    cRet
  529.     ctok    EQUAL        ; -- c-addr1 u1 c-a-buff uchars flag        R: -- uchars'
  530.     compif    rline7        ; There's a CR before the LF
  531.     ctok    R_FROM
  532.     ctok    ONE_MINUS    ; subtract yet another char from the returned count
  533.     ctok    TO_R        ; -- c-addr1 u1 c-a-buff uchars            R: -- uchars''
  534.     compelse    rline7
  535. rline6:                ; -- c-addr1 u1 c-a-buff uchars c-addr2        R: -- uchars'
  536.     ctok    DROP        ; get rid of extra address, we don't check for CR
  537. rline7:                ; -- c-addr1 u1 c-a-buff uchars            R: -- uchars''
  538.     ctok    ROT        ; -- c-addr1 c-a-buff uchars u1         R: -- uchars''
  539.     ctok    MIN        ; -- c-addr1 c-a-buff u                 R: -- uchars''
  540.     literal    0
  541.     ctok    MAX        ; -- c-addr1 c-a-buff u                 R: -- uchars''
  542.     ctok    TO_R
  543.     ctok    SWAP
  544.     ctok    R_FROM        ; -- c-a-buff c-addr1 u                 R: -- uchars''
  545.     ctok    CMOVE        ; --                        R: -- uchars''
  546.     ctok    R_FROM
  547.     ctok    TRUE
  548.     literal    0        ; -- u flag ior                    R: --
  549.     ctok    UNNEST
  550.  
  551.     fnamemanque    <REPOSITION-FILE>    ; ud fileid -- ior (== 0 | system err)
  552. fw_REPOFILE:                ; FILE
  553.     defers
  554.  
  555.     nnamemanque    <REPOSITION-FILEW>    ; ud-chars fileid -- ior (== 0 | system err)
  556. fw_REPOFILEW:                ; FILE
  557.     ctok    NEST
  558.     ctok    TO_R            ; -- ud-chars            R: -- fileid
  559.     literal    tchar            ; -- ud-chars u            R: -- fileid
  560.     ctok    UDSTARU            ; -- ud-bytess            R: -- fileid
  561.     ctok    R_FROM            ; -- ud-chars fileid        R: --
  562.     ctok    REPOFILEA        ; -- ior
  563.     ctok    UNNEST
  564.  
  565.     nnamemanque    <REPOSITION-FILEA>    ; ud-bytes fileid -- ior (== 0 | system err)
  566. fw_REPOFILEA:                ; FILE
  567.     docode
  568.     pop    edx            ; fileid
  569.     pop    DWORD PTR distMoveHigh    ; hi word of dist to move
  570.     pop    eax            ; low
  571.     INVOKE    SetFilePointer, edx, eax, OFFSET FLAT:distMoveHigh, FILE_BEGIN
  572.     cmp    eax,-1            ; if -1, must check distMoveHigh
  573.     jne    repofile1
  574.     cmp    DWORD PTR distMoveHigh,0    ; if zero, we have an err
  575.     jne    repofile1        ; not zero is success
  576.     INVOKE    GetLastError        ; get error
  577.     push    eax            ; push error ior
  578.     store    lastError,eax        ; to be consistent with rest of system
  579.     next
  580. repofile1:
  581.     xor    eax,eax
  582.     push    eax            ; success, ior is zero
  583.     next
  584.  
  585.     fnamemanque    <RESIZE-FILE>    ; ud fileid -- ior (== 0 | system err)
  586. fw_RESIZEFILE:                ; FILE
  587.     defers
  588.  
  589.     nnamemanque    <RESIZE-FILEW>    ; ud-chars fileid -- ior (== 0 | system err)
  590. fw_RESIZEFILEW:                ; FILE
  591.     ctok    NEST
  592.     ctok    TO_R            ; -- ud-chars        R: -- fileid
  593.     literal    tchar
  594.     ctok    UDSTARU            ; -- ud-bytes        R: -- fileid
  595.     ctok    R_FROM            ; -- ud-bytes fileid
  596.     ctok    RESIZEFILEA        ; -- ior
  597.     ctok    UNNEST
  598.  
  599.     nnamemanque    <RESIZE-FILEA>    ; ud-bytes fileid -- ior (== 0 | system err)
  600. fw_RESIZEFILEA:                ; FILE
  601.     ctok    NEST
  602.     ctok    DUP            ; -- ud fileid fileid
  603.     ctok    TO_R            ; -- ud fileid        R: -- fileid
  604.     ctok    REPOFILEA        ; -- flag        R: -- fileid
  605.     ctok    R_FROM            ; -- flag fileid
  606.     ctok    SWAP            ; -- fileid flag
  607.     ctok    DUP            ; -- fileid flag flag
  608.     ctok    ZEROEQ
  609.     compif    resizefile1
  610.     ctok    DROP            ; -- fileid
  611.     ctok    SETEOF            ; -- ior
  612.     ctok    EXIT
  613. resizefile1:
  614.     ctok    SWAP            ; -- ior fileid
  615.     ctok    DROP            ; -- ior
  616.     ctok    UNNEST            ; -- ior
  617.  
  618.     sname    <SETEOF>        ; fileid -- ior  Set end of file at current file pointer
  619.     docode
  620.     mov    eax,[esp]
  621.     INVOKE    SetEndOfFile, eax
  622.     and    eax,eax
  623.     je    seteofend
  624.     INVOKE    GetLastError
  625.     mov    [esp],eax
  626.     next
  627. seteofend:
  628.     xor    eax,eax
  629.     mov    [esp],eax
  630.     next
  631.  
  632.     fnamemanque    <WRITE-FILE>    ; b|c-addr u fileid -- ior (== 0 | system err)
  633. fw_WRITEFILE:
  634.     defers
  635.  
  636.     nnamemanque    <WRITE-FILEW>    ; c-addr u fileid -- ior (== 0 | system err)
  637. fw_WRITEFILEW:
  638.     ctok    NEST
  639.     ctok    SWAP            ; -- c-addr fileid u-chars
  640.     ctok    TWO_STAR        ; -- c-addr fileid u-bytes
  641.     ctok    SWAP            ; -- c-addr u-bytes fileid
  642.     ctok    WRITEFILEA        ; -- ior
  643.     ctok    UNNEST
  644.  
  645.     nnamemanque    <WRITE-FILEA>    ; b-addr u fileid -- ior (== 0 | system err)
  646. fw_WRITEFILEA:                ; FILE
  647.     docode
  648.     pop    edx            ; fileid
  649.     pop    ecx            ; u1
  650.     pop    eax            ; c-addr
  651.     add    eax,dp            ; abs-addr
  652.     INVOKE    WriteFile, edx, eax, ecx, OFFSET FLAT:numRead, 0
  653.     and    eax,eax
  654.     jne    writefile1        ; result was bool true, so we branch on success
  655.     INVOKE    GetLastError        ; get error
  656.     push    eax            ; push error ior
  657.     store    lastError,eax        ; to be consistent with rest of system
  658.     next
  659. writefile1:
  660.     xor    eax,eax
  661.     push    eax            ; success, ior is zero
  662.     next
  663.  
  664.     fnamemanque    <R/O>            ; -- x
  665. fw_RO:    ctok    DOCONST                ; FILE
  666.     dd    GENERIC_READ
  667.  
  668.     fnamemanque    <R/W>            ; -- x
  669. fw_RW:    ctok    DOCONST                ; FILE
  670.     dd    GENERIC_READ OR GENERIC_WRITE
  671.  
  672.     fnamemanque    <W/O>            ; -- x
  673. fw_WO:    ctok    DOCONST                ; FILE
  674.     dd    GENERIC_WRITE
  675.  
  676.     fname        <BIN>            ; fam1 -- fam2
  677.     docode                    ; FILE
  678.     next
  679.  
  680. ;--( BLOCK stuff )
  681.  
  682.     nnamemanque    <BLOCK-FILE>    ; -- a-addr
  683. fw_BLOCKFILE:
  684.     ctok    DOCONST
  685.     dd    blockFile        ; holds the file id for active BLOCK file
  686.  
  687.     fname    <BLOCK>        ; u -- a-addr
  688.     ctok    NEST
  689.     ctok    DUP        ; -- u u
  690.     ctok    INVALIDBLOCK    ; -- u flag
  691.     literal    -35        ; invalid block number THROW
  692.     ctok    AND        ; throw if block was invalid
  693.     ctok    THROW
  694.     ctok    BLOCKFILE    ; -- u a-addr
  695.     ctok    FETCH        ; -- u file-id
  696.     ctok    ZEROEQ        ; -- u flag
  697.     literal    -37        ; file I/O exception
  698.     ctok    AND        ; so that we either THROW a -37 or a 0 (e.g., continue on)
  699.     ctok    THROW
  700.     literal    blockNum    ; -- u a-addr
  701.     ctok    FETCH        ; -- u1 u2
  702.     ctok    OVER        ; -- u1 u2 u1
  703.     ctok    NEQUAL        ; -- u flag        TRUE if blockBuffer doesn't current hold that block number
  704.     compif    block2        ; -- u            If they are equal, jump ahead and exit
  705.     ctok    DUP        ; -- u u        Not equal, get a BUFFER
  706.     ctok    BUFFER        ; -- u a-addr
  707.     ctok    SWAP        ; -- a-addr u
  708.     literal    blockSize
  709.     ctok    UMSTAR        ; -- a-addr ud
  710.     ctok    BLOCKFILE
  711.     ctok    FETCH        ; -- a-addr ud file-id
  712.     ctok    REPOFILEW    ; -- a-addr flag
  713.     compif    block1
  714.     literal    -35        ; Invalid Block Number
  715.     ctok    THROW
  716. block1:                ; -- a-addr
  717.     literal    blockSize
  718.     ctok    BLOCKFILE
  719.     ctok    FETCH        ; -- a-addr ud file-id
  720.     ctok    READFILEW    ; -- numread ior
  721.     ctok    SWAP        ; -- ior numread
  722.     literal    blockSize    ; -- ior numread n
  723.     ctok    NEQUAL        ; -- ior flag
  724.     ctok    OR        ; -- flag
  725.     compif    block3
  726.     literal    -33        ; BLOCK read error
  727.     ctok    THROW
  728. block2:                ; -- u        we're already there
  729.     ctok    DROP        ; --
  730. block3:
  731.     literal    blockBuffer    ; -- a-addr
  732.     ctok    UNNEST
  733.  
  734.     nname    <BLOCKNUM>
  735.     ctok    DOCONST
  736.     dd    blockNum
  737.  
  738.     nname    <UPDATED>
  739.     ctok    DOCONST
  740.     dd    updated
  741.  
  742.     fname    <BUFFER>    ; u -- a-addr
  743.     ctok    NEST
  744.     literal    blockNum
  745.     ctok    FETCH        ; -- u1 u2
  746.     ctok    OVER        ; -- u1 u2 u1
  747.     ctok    NEQUAL        ; -- u flag        TRUE if blockBuffer doesn't current hold that block number
  748.     compif    buffer2
  749.     literal    updated
  750.     ctok    FETCH        ; -- u flag        Is BLOCK we're going to replace an UPDATEd BLOCK?
  751.     compif    buffer1
  752.     ctok    SAVEBUFFERS    ; -- u            Yes, save buffer(s), mark not updated
  753. buffer1:
  754.     literal    blockNum
  755.     ctok    STORE        ; --            Renumber buffer
  756.     compelse    buffer3
  757. buffer2:            ; -- u            Buffer was already present
  758.     ctok    DROP        ; --
  759. buffer3:
  760.     literal    blockBuffer    ; -- a-addr
  761.     ctok    UNNEST
  762.  
  763.     fnamemanque    <EMPTY-BUFFERS>        ; --
  764. fw_EMPTYBUFFERS:                ; BLOCK EXT
  765.     ctok    NEST
  766.     ctok    FALSE
  767.     literal    updated
  768.     ctok    STORE
  769.     ctok    TRUE
  770.     literal    blockNum
  771.     ctok    STORE
  772.     literal    blockBuffer
  773.     literal    blockSize
  774.     ctok    BL
  775.     ctok    FILL
  776.     ctok    UNNEST
  777.  
  778.     fnamemanque    <SAVE-BUFFERS>        ; --
  779. fw_SAVEBUFFERS:                    ; BLOCK
  780.     ctok    NEST
  781.     literal    updated
  782.     ctok    FETCH            ; -- flag
  783.     compif    savebuf7        ; 0 == not updated, leave
  784.     literal    blockNum
  785.     ctok    FETCH            ; -- n
  786.     ctok    TRUE
  787.     ctok    NEQUAL            ; -- flag
  788.     compif    savebuf7        ; BLOCK number of TRUE == no block, leave
  789.     ctok    BLOCKFILE
  790.     ctok    FETCH            ; -- file-id
  791.     ctok    DUP            ; -- file-id file-id
  792.     ctok    ZEROEQ            ; -- file-id flag
  793.     compif    savebuf4        ; 0 == no BLOCK file
  794.     literal    -37            ; file I/O exception
  795.     ctok    THROW
  796. savebuf4:                ; yes, there is a BLOCK file handle in the controlling blockFile variable
  797.     literal    blockNum        ; -- file-id u
  798.     ctok    FETCH
  799.     literal    blockSize        ; -- file-id u'
  800.     ctok    UMSTAR            ; -- file-id ud
  801.     literal    2
  802.     ctok    PICK            ; -- file-id ud file-id
  803.     ctok    REPOFILEW        ; -- file-id ior
  804.     compif    savebuf5
  805.     literal    -35            ; Invalid Block Number
  806.     ctok    THROW
  807. savebuf5:
  808.     literal    blockBuffer        ; -- file-id c-addr
  809.     literal blockSize        ; -- file-id c-addr u
  810.     ctok    ROT            ; -- file-id c-addr u file-id
  811.     ctok    WRITEFILEW        ; -- ior
  812.     compif    savebuf6
  813.     literal    -34            ; BLOCK write error
  814.     ctok    THROW
  815. savebuf6:
  816.     ctok    FALSE            ; -- 0
  817.     literal    updated
  818.     ctok    STORE            ; --
  819.     compelse    savebuf7
  820. savebuf7:
  821.     ctok    UNNEST
  822.  
  823.     fname    <FLUSH>        ; --
  824.     ctok    NEST        ; BLOCK
  825.     ctok    SAVEBUFFERS
  826.     ctok    EMPTYBUFFERS
  827.     ctok    UNNEST
  828.  
  829.     fname    <UPDATE>        ; --
  830.     ctok    NEST            ; BLOCK
  831.     ctok    TRUE
  832.     literal    updated
  833.     ctok    STORE
  834.     ctok    UNNEST
  835.  
  836.     fname    <SCR>        ; -- a-addr
  837.     ctok    DOCONST        ; BLOCK EXT
  838.     dd    var_scr
  839.  
  840.     fname    <LIST>        ; u --
  841.     ctok    NEST        ; BLOCK EXT
  842.     ctok    DUP
  843.     ctok    SCR
  844.     ctok    STORE        ; -- u
  845.     ctok    PAGE
  846.     ctok    DOKDOTQUOTE
  847.     dd    listMsg1
  848.     ctok    DUP        ; -- u u
  849.     ctok    DOT        ; -- u
  850.     literal    28
  851.     literal    0
  852.     ctok    AT_XY        ; center justify
  853.     ctok    DOKDOTQUOTE
  854.     dd    listMsg2
  855.     ctok    BLOCKFILE    ; -- u a-addr
  856.     ctok    FETCH        ; -- u1 fid
  857.     ctok    DOT        ; -- u1
  858.     ctok    BLOCK        ; -- a-addr
  859.     literal    16
  860.     literal    0
  861.     compdo    list2
  862. list1:    ctok    CR        ; -- a-addr
  863.     ctok    I        ; -- a-addr n
  864.     ctok    DUP        ; -- a-addr n n
  865.     literal    2
  866.     ctok    DOT_R        ; -- a-addr n
  867.     ctok    SPACE
  868.     literal    64
  869.     ctok    CHARS
  870.     ctok    STAR        ; -- a-addr n'
  871.     ctok    OVER        ; -- a-addr n' a-addr
  872.     ctok    PLUS        ; -- a-addr1 a-addr2
  873.     literal    64
  874.     ctok    TYPE        ; -- a-addr1
  875.     ctok    I
  876.     literal    2
  877.     ctok    DOT_R        ; -- a-addr
  878.     comploop    list1
  879. list2:    ctok    DROP        ; --
  880.     ctok    UNNEST
  881.  
  882.     fname    <LOAD>        ; i*x u -- j*x
  883.     ctok    NEST        ; BLOCK
  884.     ctok    QDUP
  885.     ctok    ZEROEQ
  886.     compif    load1
  887.     ctok    okPrompt
  888.     ctok    QUIT        ; Quit if Block number is 0
  889. load1:    ctok    BLK        ; Save input on return stack
  890.     ctok    FETCH
  891.     ctok    TO_R
  892.     ctok    TIB
  893.     ctok    TO_R
  894.     ctok    NUMTIB
  895.     ctok    FETCH
  896.     ctok    TO_R
  897.     ctok    TO_IN
  898.     ctok    FETCH
  899.     ctok    TO_R
  900.     ctok    SOURCE_ID
  901.     ctok    FETCH
  902.     ctok    TO_R
  903.     literal    endq
  904.     ctok    FETCH
  905.     ctok    TO_R
  906.     ctok    FALSE
  907.     literal    endq
  908.     ctok    STORE
  909.     ctok    BLK
  910.     ctok    STORE
  911.     ctok    FALSE
  912.     ctok    SOURCE_ID
  913.     ctok    STORE
  914.     ctok    FALSE
  915.     ctok    TO_IN
  916.     ctok    STORE
  917.     ctok    INTERPRET
  918.     ctok    R_FROM        ; Restore input spec
  919.     literal    endq
  920.     ctok    STORE
  921.     ctok    R_FROM
  922.     ctok    SOURCE_ID
  923.     ctok    STORE
  924.     ctok    R_FROM
  925.     ctok    TO_IN
  926.     ctok    STORE
  927.     ctok    R_FROM
  928.     ctok    NUMTIB
  929.     ctok    STORE
  930.     ctok    R_FROM
  931.     ctok    TICK_TIB
  932.     ctok    STORE
  933.     ctok    R_FROM
  934.     ctok    BLK
  935.     ctok    STORE        ; -- j*x        R: --
  936.     ctok    UNNEST
  937.  
  938.     fname    <THRU>        ; i*x u1 u2 -- j*x
  939.     ctok    NEST        ; BLOCK EXT
  940.     ctok    ONE_PLUS
  941.     ctok    SWAP
  942.     compqdo    thru2
  943. thru1:    ctok    I
  944.     ctok    LOAD
  945.     comploop    thru1
  946. thru2:    ctok    UNNEST
  947.  
  948.  
  949.     zname    <INVALIDBLOCK>    ; u -- flag
  950.     ctok    NEST
  951.     ctok    ONE_PLUS    ; we're calculating the bytes needed to complete the BLOCK.
  952.     literal    blockSize    ; -- u1 u2
  953.     ctok    UMSTAR        ; -- ud
  954.     ctok    BLOCKFILE    ; -- ud a-addr
  955.     ctok    FETCH        ; -- ud file-id
  956.     ctok    FILESIZEW    ; -- ud1 ud2 ior
  957.     ctok    ZERONE        ; -- ud1 ud2 flag
  958.     literal    -37        ; file I/O exception
  959.     ctok    AND        ; so that we either THROW a -37 or a 0 (e.g., continue on)
  960.     ctok    THROW
  961.     ctok    TWO_SWAP    ; -- ud2 ud1    
  962.     ctok    UD_LESS        ; block requested greater than blocks in file? ( ud2 < ud1 ) if so, invalid block
  963.     ctok    UNNEST
  964.  
  965. ; END of jx4files.a
  966.  
  967.